home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
pascal
/
tphers01.zip
/
TPHERSH.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-09-08
|
19KB
|
496 lines
{*****************************************************************************}
{* A unit to manipulate the Hershey glyph (symbol) set. *}
{* *}
{* This code is donated to the Public domain. *}
{* *}
{* Dov Grobgeld *}
{* Department of Chemical Physics *}
{* The Weizmann Institute of Science *}
{* Israel *}
{* Email: dov@menora.weizmann.ac.il *}
{* *}
{* 7/9/1991 *}
{* *}
{* Version 0.1beta *}
{* *}
{* There are only two dependances on BGI in this code, and both have the *}
{* keywords 'BGI dependance' in comments beside them. *}
{*****************************************************************************}
unit TPHersh;
interface
uses graph; { BGI dependance }
{$ifopt n-} type double=real; {$endif} { Use reals if no math coprocessor }
type
HersheyFont = array[#32..#127] of integer;
pHersheyFont = ^HersheyFont;
const
HersheyRomans : HersheyFont = (
699, 714, 717, 733, 719,2271, 734, 731, 721, 722,2219, 725, 711, 724, 710, 720,
700, 701, 702, 703, 704, 705, 706, 707, 708, 709, 712, 713,2241, 726,2242, 715,
2273, 501, 502, 503, 504, 505, 506, 507, 508, 509, 510, 511, 512, 513, 514, 515,
516, 517, 518, 519, 520, 521, 522, 523, 524, 525, 526,2223, 804,2224,2262, 999,
730, 601, 602, 603, 604, 605, 606, 607, 608, 609, 610, 611, 612, 613, 614, 615,
616, 617, 618, 619, 620, 621, 622, 623, 624, 625, 626,2225, 723,2226,2246, 718);
var
HersheyX, HersheyY : integer;
HersheyMaxX, HersheyAspectRatio : double;
procedure HersheySetGlyphsFileName(s : string);
procedure HersheyLoadGlyphs;
procedure HersheyDisplayGlyph(GlyphNum : integer);
procedure HersheyOutTextXY(x,y : integer; s : string);
procedure HersheyOutText(s : string);
procedure HersheySetGlyphSize(xs, ys: double);
procedure HersheyDisposeFont;
procedure HersheySetFont(var pFont);
procedure HersheyMove(x,y : integer);
function HersheyGlyphWidth(GlyphNum : integer) : double;
function HersheyStringWidth(s : string) : double;
procedure HersheySetAngle(theta : double);
procedure HersheySetStringJustify(Horizontal, Vertical : integer);
implementation
const
MaxHersheyChars = 3999;
MaxStrokes = 1000;
type
{*****************************************************************************}
{* The strokes in a character are stored in the file as integers represented *}
{* as characters centered around 'R'. *}
{* *}
{* All characters are drawn around the center of the character. The width *}
{* of the charecter is decided by +-Stroke[0] and the height is determined *}
{* by +-Stroke[1]. *}
{*****************************************************************************}
StrokeVector = array[1..MaxStrokes-1] of char;
pStrokeVector = ^StrokeVector;
HersheyChar = record
numStrokes : byte;
pStroke : pStrokeVector;
end;
HersheyFontType = array[1..MaxHersheyChars] of ^HersheyChar;
const
HersheyGlyphsFileName : string = 'hersh.hfn';
var
HersheyFontArray : ^HersheyFontType;
HersheyCurrentFont : ^HersheyFont;
SinTheta, CosTheta : double; { Rotation of character }
xiScale, nuScale : double;
HStringJust, VStringJust : double;
{*****************************************************************************}
{* Allows the user to chose another font file. *}
{*****************************************************************************}
procedure HersheySetGlyphsFileName(s : string);
begin
HersheyGlyphsFileName:= s;
end;
{*****************************************************************************}
{* FAST block read routines to read the font... *}
{*****************************************************************************}
CONST
BufLen = 8192;
TYPE
RecType = char;
ArrayRecType=Array[1..BufLen] of RecType;
VAR
FontFile : FILE;
InBuf : ^arrayRecType;
InPtr : WORD;
RecRead : WORD;
procedure OpenBlockFiles(p : pointer);
begin
{ Open the font file for unformated input }
Assign(FontFile, HersheyGlyphsFileName); Reset(FontFile, SizeOf(RecType));
RecRead:= 0;
InPtr:= RecRead + 1;
InBuf:= p;
end;
procedure CloseBlockFiles;
begin
close(FontFile);
end;
FUNCTION GetNextRec(VAR _rec; NumRecs : integer): BOOLEAN;
var
rec: ArrayRecType absolute _rec;
RecOfs : integer;
BEGIN
if NumRecs + InPtr <= Recread then begin
move(InBuf^[InPtr], rec[1], NumRecs * sizeof(RecType));
InPtr:= InPtr + NumRecs;
GetNextRec:= TRUE;
end
else begin
if RecRead >= InPtr then begin
move(InBuf^[InPtr], rec[1], (RecRead-InPtr+1) * sizeof(RecType));
RecOfs:= RecRead - InPtr + 1;
end
else RecOfs:= 0;
BlockRead(FontFile, InBuf^, BufLen, RecRead);
IF RecRead = 0 THEN BEGIN
GetNextRec:= FALSE;
Exit;
END;
InPtr:= 1;
move(InBuf^[InPtr], rec[RecOfs+1], (NumRecs - RecOfs) * sizeof(RecType));
InPtr:= InPtr + NumRecs - RecOfs;
end;
END;
{*****************************************************************************}
{* Load the font into memory. *}
{*****************************************************************************}
procedure HersheyLoadGlyphs;
var
numString : string[5];
i : integer;
GlyphNum, numStrokes : integer;
errPos : integer;
Buf : array[1..BufLen] of byte;
crlf : array[1..2] of char;
eofFlag : boolean;
label
exitLoad;
function imin(a,b : integer): integer;
begin
if a<b then imin:= a
else imin:= b;
end;
begin
if HersheyFontArray=nil then begin
new(HersheyFontArray);
{ Zero all characters }
for i:= 1 to MaxHersheyChars do HersheyFontArray^[i]:= nil;
end;
openBlockFiles(@Buf); { Let's use a stack buffer instead of a heap buffer... }
eofFlag:= false;
while not eofFlag do begin
{ Get the Hershey Glyph number and the number of strokes in the font }
numString[0]:= #5;
eofFlag:= not GetNextRec(numString[1],5);
val(numString, GlyphNum, errPos);
numString[0]:= #3;
eofFlag:= not GetNextRec(numString[1],3);
val(numString, numStrokes, errPos);
if eofFlag then goto ExitLoad;
{ Allocate the memory for the character and store it}
if HersheyFontArray^[GlyphNum] = nil then begin
new(HersheyFontArray^[GlyphNum]);
HersheyFontArray^[GlyphNum]^.numStrokes:= numStrokes;
GetMem(HersheyFontArray^[GlyphNum]^.pStroke, numStrokes * 2);
{ Copy all the characters... }
eofFlag:= not GetNextRec(HersheyFontArray^[GlyphNum]^.pStroke^[1], 2*numStrokes);
if not eofFlag then eofFlag:= not GetNextRec(crlf[1], 2); { Get CR, LF }
if ((crlf[1] <> #13) or (crlf[2] <> #10)) then begin
writeln('Warning at character ', GlyphNum, '. Expected cr/lf not found! ');
writeln('Searching for next cr/lf...');
repeat
eofFlag:= not GetNextRec(crlf[1],1);
if not eofFlag and (crlf[1]=